HPAVC/HPAVC CD-ROM.iso/pc/FH-3DTUT.ZIP/TUTUNIT.PAS

Pascal/Delphi Source File | 1995-12-24 | 10.0 KB | 461 lines

{$A+,G+,R-,S-}
UNIT TUTUNIT; {Unit by THEFAKER (C) 1994,
               Cutted by fh94.3 (C) 1995 (Sorry THEFAKER)}

INTERFACE

PROCEDURE SetPixel(X,Y:Word; C:Byte);
FUNCTION GetPixel(X,Y:Word):Byte;
PROCEDURE DrawLineH(X1,X2,Y1:Word; C:Byte);
PROCEDURE DrawLineV(X1,Y1,Y2:Word; C:Byte);
PROCEDURE DrawLine(X1,Y1,X2,Y2:Integer; C:Byte);
PROCEDURE SetColor(Nr,R,G,B:Byte);
PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
PROCEDURE Fill(X,Y:Integer; C:Byte);
PROCEDURE Flood(X,Y:Integer; C,C2:Byte);
PROCEDURE ClearScreen;
PROCEDURE MCGAOn;
PROCEDURE MCGAOff;

IMPLEMENTATION
VAR
   OldMode:Byte;

PROCEDURE SetPixel(X,Y:Word; C:Byte);
BEGIN
     ASM
        mov ax,$a000
        mov es,ax
        mov bx,x
        mov dx,y
        xchg dh,dl
        mov al,c
        mov di,dx
        shr di,1
        shr di,1
        add di,dx
        add di,bx
        stosb
     END;
END;

FUNCTION GetPixel(X,Y:Word):Byte;
BEGIN
     ASM
        mov ax,$a000
        mov es,ax
        mov bx,x
        mov dx,y
        mov di,dx
        shl di,1
        shl di,1
        add di,dx
        mov cl,6
        shl di,cl
        add di,bx
        mov al,es:[di]
        mov [bp-1],al
     END;
END;

PROCEDURE DrawLineH(X1,X2,Y1:Word; C:Byte);
BEGIN
     ASM
        mov ax,$a000
        mov es,ax
        mov ax,y1
        mov di,ax
        shl di,1
        shl di,1
        add di,ax
        mov cl,6
        shl di,cl
        mov bx,x1
        mov dx,x2
        cmp bx,dx
        jl @1
        xchg bx,dx
@1:     inc dx
        add di,bx
        mov cx,dx
        sub cx,bx
        shr cx,1
        mov al,c
        mov ah,al
        ror bx,1
        jnb @2
        stosb
        ror dx,1
        jnb @3
        dec cx
@3:     rol dx,1
@2:     rep
        stosw
        ror dx,1
        jnb @4
        stosb
@4:
     END;
END;

PROCEDURE ClearScreen;
BEGIN
     PortW[$3C4]:=$0F02;
     ASM
        mov ax,$a000
        mov es,ax
        mov cx,16383
        db $66
        xor ax,ax
        xor di,di
        cld
        db $66
        rep stosw
     END;
END;

PROCEDURE DrawLineV(X1,Y1,Y2:Word; C:Byte);
BEGIN
     ASM
        mov ax,x1
        mov bx,y1
        mov dx,y2
        cmp bx,dx
        jl @1
        xchg bx,dx
@1:     mov di,bx
        shl di,1
        shl di,1
        add di,bx
        mov cl,6
        shl di,cl
        add di,ax
        mov cx,$a000
        mov es,cx
        mov cx,dx
        sub cx,bx
        inc cx
        mov al,c
        mov bx,$13f
@2:     stosb
        add di,bx
        loop @2
     END;
END;

PROCEDURE DrawLine(X1,Y1,X2,Y2:Integer; C:Byte);
BEGIN
     ASM
        mov al,c
        xor ah,ah
        mov si,ax
        mov ax,x1
        cmp ax,319
        ja @Ende
        mov bx,x2
        cmp bx,319
        ja @Ende
        mov cx,y1
        cmp cx,199
        ja @Ende
        mov dx,y2
        cmp dx,199
        ja @Ende
        cmp ax,bx
        jnz @weiter
        cmp cx,dx
        jnz @vertical
        push ax
        push cx
        push si
        call setpixel
        jmp @ende
@weiter:cmp cx,dx
        jnz @weiter2
        push ax
        push bx
        push cx
        push si
        call drawlineh
        jmp @ende
@vertical:push ax
        push cx
        push dx
        push si
        call drawlinev
        jmp @ende
@weiter2:cmp cx,dx
        jbe @1
        xchg cx,dx
        xchg ax,bx
@1:     mov di,cx
        shl di,1
        shl di,1
        add di,cx
        push si
        mov si,bx
        mov bx,dx
        sub bx,cx
        mov cl,06
        shl di,cl
        add di,ax
        mov dx,si
        pop si
        sub dx,ax
        mov ax,$a000
        mov es,ax
        mov ax,si
        push bp
        or dx,0
        jge @jmp1
        neg dx
        cmp dx,bx
        jbe @jmp3
        mov cx,dx
        inc cx
        mov si,dx
        shr si,1
        std
        mov bp,320
@1c:    stosb
@1b:    or si,si
        jge @1a
        add di,bp
        add si,dx
        jmp @1b
@1a:    sub si,bx
        loop @1c
        jmp @Ende2
@jmp3:  mov cx,bx
        inc cx
        mov si,bx
        neg si
        sar si,1
        cld
        mov bp,319
@2c:    stosb
@2b:    or si,si
        jl @2a
        sub si,bx
        dec di
        jmp @2b
@2a:    add di,bp
        add si,dx
        loop @2c
        jmp @Ende2
@jmp1:  cmp dx,bx
        jbe @jmp4
        mov cx,dx
        inc cx
        mov si,dx
        shr si,1
        cld
        mov bp,320
@3c:    stosb
@3b:    or si,si
        jge @3a
        add di,bp
        add si,dx
        jmp @3b
@3a:    sub si,bx
        loop @3c
        jmp @Ende2
@jmp4:  mov cx,bx
        inc cx
        mov si,bx
        neg si
        sar si,1
        std
        mov bp,321
@4c:    stosb
@4b:    or si,si
        jl @4a
        sub si,bx
        inc di
        jmp @4b
@4a:    add di,bp
        add si,dx
        loop @4c
@Ende2: pop bp
        cld
@Ende:
     END;
END;

PROCEDURE SetColor(Nr,R,G,B:Byte);
BEGIN
     Port[$3C8]:=Nr;
     Port[$3C9]:=R;
     Port[$3C9]:=G;
     Port[$3C9]:=B;
END;

PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
BEGIN
     Port[$3C7]:=Nr;
     R:=Port[$3C9];
     G:=Port[$3C9];
     B:=Port[$3C9];
END;

PROCEDURE Fill(X,Y:Integer; C:Byte);
VAR
   C2:Byte;

   PROCEDURE Suchen(L,R,Y:Integer; UpDown:Byte);
   VAR
      X,X2:Integer;
   BEGIN
        IF GetPixel(L,Y)=C2 THEN
           WHILE (L>0) AND (GetPixel(L-1,Y)=C2) DO
                 Dec(L);
        X:=L;
        IF GetPixel(R,Y)=C2 THEN
           WHILE (R<319) AND (GetPixel(R+1,Y)=C2) DO
                 Inc(R);
        WHILE X<=R DO
        BEGIN
             X2:=X;
             IF GetPixel(X,Y)=C2 THEN
             BEGIN
                  WHILE (GetPixel(X+1,Y)=C2) AND (X<319) DO
                        Inc(X);
                  DrawLineH(X2,X,Y,C);
                  IF UpDown=2 THEN
                  BEGIN
                       IF Y>0 THEN
                          Suchen(X2,X,Y-1,2);
                       IF Y<199 THEN
                          IF (L>X2) AND (R<X) THEN
                          BEGIN
                               Suchen(X2,L-1,Y+1,1);
                               Suchen(R+1,X,Y+1,1);
                          END
                          ELSE
                          IF (L<=X2) AND (R<X) THEN
                             Suchen(R+1,X,Y+1,1)
                          ELSE
                          IF (L>X2) AND (R>=X) THEN
                             Suchen(X2,L-1,Y+1,1);
                  END;
                  IF UpDown=1 THEN
                  BEGIN
                       IF Y<199 THEN
                          Suchen(X2,X,Y+1,1);
                       IF Y>0 THEN
                          IF (L>X2) AND (R<X) THEN
                          BEGIN
                               Suchen(X2,L-1,Y-1,2);
                               Suchen(R+1,X,Y-1,2);
                          END
                          ELSE
                          IF (L<=X2) AND (R<X) THEN
                             Suchen(R+1,X,Y-1,2)
                          ELSE
                          IF (L>X2) AND (R>=X) THEN
                             Suchen(X2,L-1,Y-1,2);
                  END;
             END;
             Inc(X);
        END;
   END;

BEGIN
     C2:=GetPixel(X,Y);
     IF Y<>0 THEN
        Dec(Y);
     Suchen(X,X,Y,2);
     Suchen(X,X,Y+1,1);
END;

PROCEDURE Flood(X,Y:Integer; C,C2:Byte);

   PROCEDURE Suchen(L,R,Y:Integer; UpDown:Byte);
   VAR
      X,X2:Integer;
   BEGIN
        IF GetPixel(L,Y)<>C2 THEN
           WHILE (L>0) AND (GetPixel(L-1,Y)<>C2) DO
                 Dec(L);
        X:=L;
        IF GetPixel(R,Y)<>C2 THEN
           WHILE (R<319) AND (GetPixel(R+1,Y)<>C2) DO
                 Inc(R);
        WHILE X<=R DO
        BEGIN
             X2:=X;
             IF GetPixel(X,Y)<>C2 THEN
             BEGIN
                  WHILE (GetPixel(X+1,Y)<>C2) AND (X<319) DO
                        Inc(X);
                  DrawLineH(X2,X,Y,C);
                  IF UpDown=2 THEN
                  BEGIN
                       IF Y>0 THEN
                          Suchen(X2,X,Y-1,2);
                       IF Y<199 THEN
                          IF (L>X2) AND (R<X) THEN
                          BEGIN
                               Suchen(X2,L-1,Y+1,1);
                               Suchen(R+1,X,Y+1,1);
                          END
                          ELSE
                          IF (L<=X2) AND (R<X) THEN
                             Suchen(R+1,X,Y+1,1)
                          ELSE
                          IF (L>X2) AND (R>=X) THEN
                             Suchen(X2,L-1,Y+1,1);
                  END;
                  IF UpDown=1 THEN
                  BEGIN
                       IF Y<199 THEN
                          Suchen(X2,X,Y+1,1);
                       IF Y>0 THEN
                          IF (L>X2) AND (R<X) THEN
                          BEGIN
                               Suchen(X2,L-1,Y-1,2);
                               Suchen(R+1,X,Y-1,2);
                          END
                          ELSE
                          IF (L<=X2) AND (R<X) THEN
                             Suchen(R+1,X,Y-1,2)
                          ELSE
                          IF (L>X2) AND (R>=X) THEN
                             Suchen(X2,L-1,Y-1,2);
                  END;
             END;
             Inc(X);
        END;
   END;

BEGIN
     IF Y<>0 THEN
        Dec(Y);
     Suchen(X,X,Y,2);
     Suchen(X,X,Y+1,1);
END;

PROCEDURE MCGAOn;
BEGIN
     ASM
        mov ah,$f
        int $10
        mov [offset oldmode],al
     END;
     ASM
        mov ax,$13
        int $10
     END;
END;

PROCEDURE MCGAOff;
BEGIN
     ASM
        mov al,[offset oldmode]
        xor ah,ah
        int $10
     END;
END;

END.